home *** CD-ROM | disk | FTP | other *** search
/ Amiga Collections: Taifun / Taifun 006 (1987-02-15)(Ossowski, Stefan)(DE)(PD).zip / Taifun 006 (1987-02-15)(Ossowski, Stefan)(DE)(PD).adf / Crystal-Vision (.txt) < prev    next >
AmigaBASIC Source Code  |  1987-03-04  |  10KB  |  368 lines
  1. ' Crystal Vision By Jeff White
  2. ' Placed In The Public Domain By Merlin's Software
  3. ' Subroutine To Load Graphics By Carolyn Scheppner
  4. CLEAR 32000,45000
  5. Main:
  6. DIM bPlane&(5), cTabWork%(32), cTabSave%(32),p(60)
  7. DECLARE FUNCTION xOpen&  LIBRARY
  8. DECLARE FUNCTION xRead&  LIBRARY
  9. DECLARE FUNCTION xWrite& LIBRARY
  10. DECLARE FUNCTION IoErr&  LIBRARY
  11. DECLARE FUNCTION AllocMem&() LIBRARY
  12. DIM g(40,40),h(40,40),i(40,40),j(20,20),k(20,20),l(20,20),m(20,20),n(20,20)
  13. LIBRARY "dos.library"
  14. LIBRARY "exec.library"
  15. LIBRARY "graphics.library"
  16. FOR m = 0 TO 8: READ MM%(m): NEXT m
  17. DATA 85,0,160,1,15500,64,0,0,0
  18. SAY TRANSLATE$("ONE MOMENT PLEASE."),MM%
  19. title:
  20. acbmname$ = "crystal.pic" 
  21. loadError$ = ""
  22. GOSUB LoadACBM
  23. IF loadError$ <> "" THEN GOTO Mcleanup
  24. Mcleanup:
  25. GOTO ROUTINE
  26. Mcleanup2:
  27. LIBRARY CLOSE
  28. IF loadError$ <> "" THEN PRINT loadError$
  29. END
  30. LoadACBM:
  31. f$ = acbmname$
  32. fHandle& = 0
  33. mybuf& = 0
  34. foundBMHD = 0
  35. foundCMAP = 0
  36. foundCAMG = 0
  37. foundCCRT = 0
  38. foundABIT = 0
  39. filename$ = f$ + CHR$(0)
  40. fHandle& = xOpen&(SADD(filename$),1005)
  41. IF fHandle& = 0 THEN
  42.    loadError$ = "Can't open/find pic file"
  43.    GOTO Lcleanup
  44. END IF
  45. ClearPublic& = 65537
  46. mybufsize& = 360
  47. mybuf& = AllocMem&(mybufsize&,ClearPublic&)
  48. IF mybuf& = 0 THEN
  49.    loadError$ = "Can't alloc buffer"
  50.    GOTO Lcleanup
  51. END IF
  52. inbuf& = mybuf&
  53. cbuf& = mybuf& + 120
  54. ctab& = mybuf& + 240
  55. rLen& = xRead&(fHandle&,inbuf&,12)
  56. tt$ = ""
  57. FOR kk = 8 TO 11
  58.    tt% = PEEK(inbuf& + kk)
  59.    tt$ = tt$ + CHR$(tt%)
  60. NEXT
  61. IF tt$ <> "ACBM" THEN 
  62.    loadError$ = "Not an ACBM pic file"
  63.    GOTO Lcleanup
  64. END IF
  65. ChunkLoop:
  66. REM - Get Chunk name/length
  67.  rLen& = xRead&(fHandle&,inbuf&,8)
  68.  icLen& = PEEKL(inbuf& + 4)
  69.  tt$ = ""
  70.  FOR kk = 0 TO 3
  71.     tt% = PEEK(inbuf& + kk)
  72.     tt$ = tt$ + CHR$(tt%)
  73.  NEXT   
  74. IF tt$ = "BMHD" THEN  'BitMap header 
  75.    foundBMHD = 1
  76.    rLen& = xRead&(fHandle&,inbuf&,icLen&)
  77.    iWidth%  = PEEKW(inbuf&)
  78.    iHeight% = PEEKW(inbuf& + 2)
  79.    iDepth%  = PEEK(inbuf& + 8)  
  80.    iCompr%  = PEEK(inbuf& + 10)
  81.    scrWidth%  = PEEKW(inbuf& + 16)
  82.    scrHeight% = PEEKW(inbuf& + 18)
  83.    iRowBytes% = iWidth% /8
  84.    scrRowBytes% = scrWidth% / 8
  85.    nColors%  = 2^(iDepth%)
  86.    AvailRam& = FRE(-1)
  87.    NeededRam& = ((scrWidth%/8)*scrHeight%*(iDepth%+1))+5000
  88.    IF AvailRam& < NeededRam& THEN
  89.       loadError$ = "Not enough free ram."
  90.       GOTO Lcleanup
  91.    END IF
  92.    kk = 1
  93.    IF scrWidth% > 320 THEN kk = kk + 1
  94.    IF scrHeight% > 200  THEN kk = kk + 2
  95.    SCREEN 2,scrWidth%,scrHeight%,iDepth%,kk
  96.   WINDOW 2,"Crystal Vision",,15,2
  97.   SCREEN 3,scrWidth%,scrHeight%,iDepth%,kk
  98.    REM - Get addresses of structures
  99.    GOSUB GetScrAddrs
  100.    REM - Black out screen
  101.    CALL LoadRGB4&(sViewPort&,ctab&,nColors%)
  102. ELSEIF tt$ = "CMAP" THEN  'ColorMap
  103.    foundCMAP = 1
  104.    rLen& = xRead&(fHandle&,cbuf&,icLen&)
  105.    REM - Build Color Table
  106.    FOR kk = 0 TO nColors% - 1
  107.       red% = PEEK(cbuf&+(kk*3))
  108.       gre% = PEEK(cbuf&+(kk*3)+1)
  109.       blu% = PEEK(cbuf&+(kk*3)+2)
  110.       regTemp% = (red%*16)+(gre%)+(blu%/16)
  111.       POKEW(ctab&+(2*kk)),regTemp%
  112.    NEXT
  113. ELSEIF tt$ = "CAMG" THEN 'Amiga ViewPort Modes
  114.    foundCAMG = 1
  115.    rLen& = xRead&(fHandle&,inbuf&,icLen&)
  116.    camgModes& = PEEKL(inbuf&)
  117. ELSEIF tt$ = "CCRT" THEN 'Graphicraft color cycle info
  118.    foundCCRT = 1
  119.    rLen& = xRead&(fHandle&,inbuf&,icLen&)
  120.    ccrtDir%    = PEEKW(inbuf&)
  121.    ccrtStart%  = PEEK(inbuf& + 2)
  122.    ccrtEnd%    = PEEK(inbuf& + 3)
  123.    ccrtSecs&   = PEEKL(inbuf& + 4)
  124.    ccrtMics&   = PEEKL(inbuf& + 8)
  125. ELSEIF tt$ = "ABIT" THEN  'Contiguous BitMap 
  126.    foundABIT = 1
  127.    plSize& = (scrWidth%/8) * scrHeight%
  128.    FOR pp = 0 TO iDepth% -1
  129.       rLen& = xRead&(fHandle&,bPlane&(pp),plSize&)   
  130.    NEXT
  131. ELSE 
  132.    REM - Reading unknown chunk  
  133.    FOR kk = 1 TO icLen&
  134.       rLen& = xRead&(fHandle&,inbuf&,1)
  135.    NEXT
  136.    REM - If odd length, read 1 more byte
  137.    IF (icLen& OR 1) = icLen& THEN 
  138.       rLen& = xRead&(fHandle&,inbuf&,1)
  139.    END IF
  140. END IF
  141. IF foundBMHD AND foundCMAP AND foundABIT THEN
  142.    GOTO GoodLoad
  143. END IF
  144. IF rLen& > 0 THEN GOTO ChunkLoop
  145. IF rLen& < 0 THEN  'Read error
  146.    loadError$ = "Read error"
  147.    GOTO Lcleanup
  148. END IF   
  149. IF (foundBMHD=0) OR (foundABIT=0) OR (foundCMAP=0) THEN
  150.    loadError$ = "Needed ILBM chunks not found"
  151.    GOTO Lcleanup
  152. END IF
  153. GoodLoad:
  154. loadError$ =""
  155. IF foundCMAP THEN 
  156.    CALL LoadRGB4&(sViewPort&,ctab&,nColors%)
  157. END IF
  158. Lcleanup:
  159. IF fHandle& <> 0 THEN CALL xClose&(fHandle&)
  160. IF mybuf& <> 0 THEN CALL FreeMem&(mybuf&,mybufsize&)
  161. RETURN
  162. GetScrAddrs:
  163. REM - Get addresses of screen structures
  164.    sWindow&   = WINDOW(7)
  165.    sScreen&   = PEEKL(sWindow& + 46)
  166.    sViewPort& = sScreen& + 44
  167.    sRastPort& = sScreen& + 84
  168.    sColorMap& = PEEKL(sViewPort& + 4)
  169.    colorTab&  = PEEKL(sColorMap& + 4)
  170.    sBitMap&   = PEEKL(sRastPort& + 4)
  171.    scrWidth%  = PEEKW(sScreen& + 12)
  172.    scrHeight% = PEEKW(sScreen& + 14)
  173.    scrDepth%  = PEEK(sBitMap& + 5)
  174.    nColors%   = 2^scrDepth%
  175.    FOR kk = 0 TO scrDepth% - 1
  176.       bPlane&(kk) = PEEKL(sBitMap&+8+(kk*4))
  177.    NEXT
  178. RETURN
  179.  
  180. ROUTINE:
  181. WINDOW OUTPUT 2
  182. GET (130,59)-(188,127),g
  183. GET (29,59)-(87,127),h
  184. GET (226,59)-(284,127),i
  185. GET (28,5)-(69,53),j
  186. GET (225,5)-(266,53),k
  187. GET (28,131)-(61,173),l
  188. GET (214,131)-(247,173),m
  189. GET (252,131)-(285,173),n
  190. LINE (27,5)-(70,54),12,bf
  191. LINE (223,5)-(266,54),12,bf
  192. LINE (28,131)-(61,173),12,bf
  193. LINE (214,131)-(285,173),12,bf
  194. LINE (27,56)-(90,130),12,bf
  195. LINE (224,56)-(286,130),12,bf
  196. LINE (130,59)-(188,127),29,bf
  197. SCREEN CLOSE 3
  198. GOSUB appear3
  199. SAY TRANSLATE$("are you ready to select a card."),MM%
  200. GOSUB SWITCH
  201. SAY TRANSLATE$("MASTER. HAVE A SPECTAYTOR SELECT A CARD. ANY CARD."),MM%
  202. SAY TRANSLATE$("CLICK ON YES WHEN THEY HAVE FINISHED."),MM%
  203. GOSUB SWITCH
  204. SAY TRANSLATE$("CONSINTRATE ON YOUR CARD."),MM%
  205. GOSUB appear
  206. SAY TRANSLATE$("WOULD YOU LIKE TO TRY AGAIN."),MM%
  207. GOSUB SWITCH
  208. IF MOUSE(4) >90 THEN GOTO FINISHED
  209. SAY TRANSLATE$("MASTER. HAVE A SPECTAYTOR SELECT A CARD."),MM%
  210. SAY TRANSLATE$("CLICK ON YES WHEN THEY HAVE FINISHED."),MM%
  211. GOSUB SWITCH
  212. GOSUB appear1
  213. SAY TRANSLATE$("CARE TO TEST ME ONCE MORE"),MM%
  214. GOSUB SWITCH
  215. IF MOUSE(4) >90 THEN GOTO FINISHED
  216. SAY TRANSLATE$("MASTER. ONE MORE TIME FOR THE NON BELEAVERS."),MM%
  217. SAY TRANSLATE$("CLICK ON YES WHEN THEY HAVE FINISHED."),MM%
  218. GOSUB SWITCH
  219. GOSUB appear2
  220. FINISHED:
  221. PUT (138,65),k,PSET
  222. SAY TRANSLATE$("I HOPE YOU HAVE ENJOYED THIS DEMONSTRATION."),MM%
  223. PUT (138,65),j,PSET
  224. SAY TRANSLATE$(" "),MM%
  225. FOR T= 1 TO 1000: NEXT
  226. PUT (138,65),k,PSET
  227. SAY TRANSLATE$("GOOD BY UNTIL WE MEET AGAIN."),MM%
  228. PUT (138,65),j,PSET
  229. y= 65
  230. FOR T= 1 TO 50
  231. LINE (138,y)-(180,y),29,bf
  232. y= y+1
  233. FOR x= 1 TO 100: NEXT
  234. NEXT
  235. y= 65
  236. FOR T= 1 TO 50
  237. LINE (138,y)-(180,y),29,bf
  238. y= y+1
  239. FOR x= 1 TO 100: NEXT
  240. NEXT
  241. SYSTEM
  242. appear:
  243. FOR T= 1 TO 6000: NEXT
  244. SAY TRANSLATE$(" think harder. i can not get an image."),MM%
  245. FOR T= 1 TO 6000: NEXT
  246. SAY TRANSLATE$(" i have it now. your card was the king of harts."),MM%
  247. a= 0.63
  248. PALETTE 1,a,a,a
  249. PUT(130,59),g,PSET
  250. FOR T= 1 TO 62
  251. a= a+ 0.005
  252. PALETTE 1,a,a,a
  253. NEXT
  254. FOR T= 1 TO 5000: NEXT
  255. FOR T= 1 TO 62
  256. a= a- 0.005
  257. PALETTE 1,a,a,a
  258. NEXT
  259. LINE (130,59)-(188,127),29,bf
  260. RETURN
  261. appear1:
  262. SAY TRANSLATE$("CONSINTRATE ON YOUR CARD."),MM%
  263. FOR T= 1 TO 3000: NEXT
  264. SAY TRANSLATE$("THAT WAS EASY. YOUR CARD WAS THE 8 OF SPAYIDS."),MM%
  265. FOR T= 1 TO 3000: NEXT
  266. a= 0.63
  267. PALETTE 1,a,a,a
  268. PUT(130,59),h,PSET
  269. FOR T= 1 TO 62
  270. a= a+ 0.005
  271. PALETTE 1,a,a,a
  272. NEXT
  273. FOR T= 1 TO 5000: NEXT
  274. FOR T= 1 TO 62
  275. a= a- 0.005
  276. PALETTE 1,a,a,a
  277. NEXT
  278. LINE (130,59)-(188,127),29,bf
  279. RETURN
  280. appear2:
  281. SAY TRANSLATE$("CONSINTRATE ."),MM%
  282. FOR T= 1 TO 5000: NEXT
  283. SAY TRANSLATE$("SO YOU THINK YOU CAN FOOL ZARDOZ."),MM%
  284. FOR T= 1 TO 3000: NEXT
  285. SAY TRANSLATE$("YOUR CARD WAS THE 3 OF DYEMONDS."),MM%
  286. a= 0.63
  287. PALETTE 1,a,a,a
  288. PUT(130,59),i,PSET
  289. FOR T= 1 TO 62
  290. a= a+ 0.005
  291. PALETTE 1,a,a,a
  292. NEXT
  293. FOR T= 1 TO 5000: NEXT
  294. FOR T= 1 TO 62
  295. a= a- 0.005
  296. PALETTE 1,a,a,a
  297. NEXT
  298. LINE (130,59)-(188,127),29,bf
  299. RETURN
  300. appear3:
  301. PUT (138,65),k,PSET
  302. SAY TRANSLATE$("MERLINS SOFTWARE PRESENTS."),MM%
  303. PUT (138,65),j,PSET
  304. SAY TRANSLATE$(" "),MM%
  305. FOR T= 1 TO 1000: NEXT
  306. PUT (138,65),k,PSET
  307. SAY TRANSLATE$("crystal vision."),MM%
  308. PUT (138,65),j,PSET
  309. FOR T= 1 TO 1000: NEXT
  310. PUT (138,65),k,PSET
  311. SAY TRANSLATE$("my name"),MM%
  312. PUT (138,65),j,PSET
  313. FOR T= 1 TO 1000: NEXT
  314. PUT (138,65),k,PSET
  315. SAY TRANSLATE$("is zardoz."),MM%
  316. PUT (138,65),j,PSET
  317. SAY TRANSLATE$(" "),MM%
  318. FOR T= 1 TO 1000: NEXT
  319. PUT (138,65),k,PSET
  320. SAY TRANSLATE$("I will now demonstrate my powers of telepathy."),MM%
  321. PUT (138,65),j,PSET
  322. SAY TRANSLATE$(" "),MM%
  323. FOR T= 1 TO 1000: NEXT
  324. PUT (138,65),k,PSET
  325. SAY TRANSLATE$("lets BEGIN."),MM%
  326. PUT (138,65),j,PSET
  327. y= 65
  328. FOR T= 1 TO 50
  329. LINE (138,y)-(180,y),29,bf
  330. y= y+1
  331. FOR x= 1 TO 100: NEXT
  332. NEXT
  333. RETURN
  334. SWITCH:
  335. a= 0.63
  336. PALETTE 1,a,a,a
  337. PUT(142,68),l,PSET
  338. FOR T= 1 TO 62
  339. a= a+ 0.005
  340. PALETTE 1,a,a,a
  341. NEXT
  342. CHOOSE:
  343. IF MOUSE(0) <> 1 THEN CHOOSE
  344. IF MOUSE(4) <78 THEN GOTO yes
  345. IF MOUSE(4) >90 THEN GOTO no
  346. GOTO CHOOSE
  347. yes:
  348. PUT (142,68),n,PSET
  349. FOR T= 1 TO 3000: NEXT
  350. FOR T= 1 TO 62
  351. a= a- 0.005
  352. PALETTE 1,a,a,a
  353. NEXT
  354. LINE (142,68)-(190,120),29,bf
  355. RETURN
  356. no:
  357. PUT (142,68),m,PSET
  358. FOR T= 1 TO 3000: NEXT
  359. FOR T= 1 TO 62
  360. a= a-0.005
  361. PALETTE 1,a,a,a
  362. NEXT
  363. LINE (142,68)-(190,120),29,bf
  364. RETURN
  365.  
  366.  
  367.  
  368.